home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / sml_nj / 93src.lha / src / vax / vax.sml next >
Encoding:
Text File  |  1993-01-27  |  8.9 KB  |  269 lines

  1.  
  2. (* Copyright 1989 by AT&T Bell Laboratories *)
  3. functor VaxCM(V : VAXCODER) : CMACHINE = struct
  4.  
  5. structure V' : sig exception BadReal of string
  6.            datatype Register = reg of int
  7.  
  8.            eqtype Label sharing type Label = V.Label
  9.            datatype EA = direct of Register
  10.                 | autoinc of Register
  11.                 | autodec of Register
  12.                 | displace of int * Register
  13.                 | deferred of int * Register
  14.                 | immed of int
  15.                 | immedlab of Label
  16.                 | address of Label
  17.                 | index of EA * Register
  18.  
  19.         end = V
  20. open V' System.Tags
  21.  
  22. datatype condition = NEQ | EQL | LEQ | GEQ | LSS | GTR
  23.  
  24. fun defer(direct r) = displace(0,r)
  25.   | defer(displace z) = deferred z
  26.   | defer(immedlab lab) = address lab
  27.   | defer _ = ErrorMsg.impossible "defer in cpsvax"
  28.  
  29. val sp' = reg 14
  30. val exnptr = direct(reg 13)
  31. val dataptr as direct dataptr' = direct(reg 12)
  32. val datalimit = direct(reg 8)
  33. val arithtemps as [arithtemp as direct arithtemp'] = [direct(reg 9)]
  34. val storeptr = direct(reg 11)
  35. val standardclosure = direct(reg 2)
  36. val standardarg = direct(reg 0)
  37. val standardcont = direct(reg 1)
  38. val standardlink = direct(reg 3)
  39. val miscregs = map (direct o reg) [4,5,6,7,10]
  40. val savedfpregs = [] : EA list
  41. val N_FLOAT_REGS = 16
  42. val varptr = displace(N_FLOAT_REGS*8,sp')
  43. val varptr_indexable = false
  44. val fp_base = sp'
  45. val floatregs = 
  46.     let fun from(n,m) = if n>=m then [] else n::from(n+1,m)
  47.     in map (fn r => displace(r*8, fp_base)) (from(0,N_FLOAT_REGS))
  48.     end
  49.  
  50. fun newlabel() = immedlab(V.newlabel())
  51. fun emitlab(i,immedlab lab) = V.emitlab(i,lab)
  52. fun define (immedlab lab) = V.define lab
  53.  
  54. fun beginStdFn _ = ()
  55.  
  56. (* checkLimit (n, lab):
  57.  * Generate code to check the heap limit to see if there is enough free space
  58.  * to allocate n bytes.
  59.  *)
  60. fun testLimit()=
  61.     V.cmpl(dataptr,datalimit)
  62.  
  63. val startgc_offset = 0
  64. val mask_offset = 4 (* not really 4, fix this some time *)
  65.  
  66. fun checkLimit (max_allocation,lab,mask) = 
  67.    let val lab' = V.newlabel()
  68.     in V.comment ("begin fun, max alloc = "^(makestring max_allocation)^"\n");
  69.        if max_allocation >= 4096
  70.        then (V.addl3(dataptr,immed(max_allocation-4096),arithtemp);
  71.          V.cmpl(arithtemp,datalimit))
  72.        else ();
  73.        V.bleq(address lab');
  74.        V.movl(mask, displace(mask_offset,sp'));
  75.        V.movl(lab, arithtemp);
  76.        V.jmp(deferred(startgc_offset,sp'));
  77.        V.define lab'
  78.    end
  79.  
  80. val align = V.align
  81. val mark = V.mark
  82. fun move(args2 as (displace(_, b1),displace(_, b2))) =
  83.     if b1 = fp_base andalso b2 = fp_base then V.movg args2 else V.movl args2
  84.   | move args2 = V.movl args2
  85. val emitlong = V.emitlong
  86. val realconst = V.realconst
  87. val emitstring = V.emitstring
  88.  
  89. fun jmpindexb(lab,direct y) = V.jmp(index(defer lab, y))
  90.   | jmpindexb(lab,y) = (move(y,arithtemp); V.jmp(index(defer lab, arithtemp')))
  91.  
  92. fun record(vl, z) =
  93.     let open CPS
  94.     val len = List.length vl
  95.     fun f(i,nil) = ()
  96.       | f(i,(direct r, SELp(j,p))::rest) = f(i,(displace(j*4,r),p)::rest)
  97.       | f(i,z::(direct s, SELp(j,p))::rest) =
  98.             f(i,z::(displace(4*j,s),p)::rest)
  99.       | f(i,(x as direct(reg r), OFFp 0)::
  100.         (y0 as (y as direct(reg s), OFFp 0))::rest) =
  101.         if (s+1=r) then (V.movq(y,displace((i-1)*4,dataptr'));
  102.                  f(i-2,rest))
  103.             else (V.movl(x,displace(i*4,dataptr')); f(i-1,y0::rest))
  104.       | f(i,(x as displace(j,r),OFFp 0)::(y as displace(k,s),OFFp 0)::rest) =
  105.         if k+4=j andalso r=s
  106.              then (V.movq(y,displace((i-1)*4,dataptr')); f(i-2,rest))
  107.              else (V.movl(x,displace(i*4,dataptr')); 
  108.                f(i-1,(y,OFFp 0)::rest))
  109.       | f(i,(x,OFFp 0)::rest) = (V.movl(x,displace(i*4,dataptr'));
  110.                      f(i-1,rest))
  111.       | f(i,(displace kr,SELp(0,p))::rest) = f(i,(deferred kr,p)::rest)
  112.       | f(i,(direct r, OFFp j)::rest) = (V.moval(displace(j*4,r),
  113.                             displace(i*4,dataptr'));
  114.                          f(i-1,rest))
  115.       | f(i,(x,p)::rest) = (V.movl(x,arithtemp); f(i,(arithtemp,p)::rest))
  116.       in f(len - 2, rev vl);
  117.      V.movl(dataptr,z);
  118.          V.addl2(immed(4*len), dataptr)
  119.      end
  120.  
  121.   (* recordStore(x, y, alwaysBoxed) records a store operation into mem[x+2*(z-1)].
  122.    * The flag alwaysBoxed is true if the value stored is guaranteed to be boxed.
  123.    *)
  124.     fun recordStore (x, y, _) = record ([
  125.         (immed(System.Tags.make_desc(3, System.Tags.tag_record)), CPS.OFFp 0),
  126.         (x, CPS.OFFp 0), (y, CPS.OFFp 0), (storeptr, CPS.OFFp 0)
  127.       ], storeptr)
  128.  
  129. fun select(i, direct r, s) = V.movl(displace(i*4,r),s)
  130.   | select(0, a, s) = V.movl(defer a, s)
  131.  
  132. fun offset(i, direct r, s) = V.moval(displace(i*4,r),s)
  133.  
  134. val add = V.addl3
  135. val addt = add
  136. val op sub = V.subl3
  137. val subt = op sub
  138. val ashl = V.ashl
  139. fun ashr(immed i, b, c) = V.ashl(immed (~i), b, c)
  140.   | ashr(a,b,c) = (V.subl3(a,immed 0,c);
  141.            V.ashl(c,b,c))
  142.  
  143. val mult = V.mull2
  144. val divt = V.divl2
  145. val orb = V.bisl3
  146. fun andb (a,b,c) = (V.subl3(a,immed ~1,arithtemp);  (* potential bug, if
  147.                           generic.sml is changed! *)
  148.             V.bicl3(arithtemp,b,c))
  149. fun notb (a,b) = V.subl3(a,immed(~1),b)
  150. val xorb = V.xorl3
  151.  
  152.                     (* y <- mem[x+4*(z-1)] *)
  153. fun fetchindexd(x as direct x',y as displace(_,base),z) = 
  154.     if base <> fp_base then 
  155.     ErrorMsg.impossible "vax/vax/fetchindexd: dst not floating register"
  156.     else (case z 
  157.         of immed i => V.movg(displace(4*(i-1),x'), y)
  158.          | direct _ => (V.ashl(immed 2,z,arithtemp);
  159.                 V.addl3(arithtemp,x,arithtemp);
  160.                 V.movg(displace(~4,arithtemp'),y))
  161.          | _ => ErrorMsg.impossible "vax/vax/fetchindexd: bad index")
  162.   | fetchindexd _ =  ErrorMsg.impossible "vax/vax/fetchindexd"
  163.  
  164.                     (* mem[y+4*(z-1)] <- x *)
  165. fun storeindexd(x as displace(_,base),y as direct y',z) =
  166.     if base <> fp_base then
  167.     ErrorMsg.impossible "vax/vax/storeindexd: src not floating register"
  168.     else (case z 
  169.         of immed i => V.movg(x,displace(4*(i-1),y'))
  170.          | direct _ => (V.ashl(immed 2,z,arithtemp);
  171.                 V.addl3(arithtemp,y,arithtemp);
  172.                 V.movg(x,displace(~4,arithtemp')))
  173.          | _ => ErrorMsg.impossible "vax/vax/storeindexd: bad index")
  174.   | storeindexd _ = ErrorMsg.impossible "vax/vax/storeindexd"
  175.  
  176. fun fetchindexl(v,w, immed 1) = V.movl(defer v, w)
  177.   | fetchindexl(direct v, w, immed k) = V.movl(displace(2*k-2,v), w)
  178.   | fetchindexl(v,w,i) = 
  179.         (V.ashl(immed ~1,i,arithtemp);
  180.          V.movl(index(defer v, arithtemp'),w))
  181. fun storeindexl(v,w, immed 1) = V.movl(v, defer w)
  182.   | storeindexl(v, direct w, immed k) = V.movl(v, displace(2*k-2, w))
  183.   | storeindexl(v,w,i) = 
  184.         (V.ashl(immed ~1,i,arithtemp);
  185.          V.movl(v,index(defer w, arithtemp')))
  186.  
  187. (* fetchindexb(x,y,z) fetches a byte: y <- mem[x+z], where y is not arithtemp *)
  188. fun fetchindexb (x, y, direct indx) = V.movzbl(index(defer x, indx), y)
  189.   | fetchindexb (direct x, y, immed indx) = V.movzbl(displace(indx, x), y)
  190.  
  191. (* storeindexb(x,y,z) stores a byte: mem[y+z] <- x. *)
  192. fun storeindexb (x, y, direct indx) = V.movb(x, index(defer y, indx))
  193.   | storeindexb (x, direct y, immed indx) = V.movb(x, displace(indx, y))
  194.  
  195. fun loadfloat(src,dst) =
  196.     let val msg = "vax/vax/loadfloat: Bad destination register"
  197.     in case dst 
  198.      of displace(_,base) =>  if base = fp_base then V.movg(defer src, dst)
  199.                   else ErrorMsg.impossible msg
  200.       | _ => ErrorMsg.impossible msg
  201.     end
  202.  
  203. fun storefloat(src,dst) =
  204.     let val msg = "vax/vax/storefloat: bad source register"
  205.     in case src of
  206.     displace(_, base) => if base = fp_base 
  207.                      then (V.movg(src, defer dataptr);
  208.                    V.movl(immed(desc_reald),displace(~4,dataptr'));
  209.                    V.movl(dataptr,dst);
  210.                    V.addl2(immed(4*3), dataptr))
  211.                  else ErrorMsg.impossible msg
  212.       | _ => ErrorMsg.impossible msg
  213.     end
  214.           
  215.  
  216. fun realop f (op1 as displace(_,b1),op2 as displace(_,b2),op3 as displace(_,b3)) =
  217.     if b1 <> fp_base orelse b2 <> fp_base orelse b3 <> fp_base 
  218.     then ErrorMsg.impossible "vax/vax/realop: Bad registers to float operator"
  219.     else f (op1,op2,op3)
  220.  
  221. val fmuld = realop V.mulg3
  222. val fdivd = realop (fn (a,b,c) => V.divg3 (b,a,c))
  223. val faddd = realop V.addg3
  224. val fsubd = realop (fn (a,b,c) => V.subg3 (b,a,c))
  225. fun fnegd(src as displace(_,b1),dst as displace(_,b2)) = 
  226.     if b1<>fp_base andalso b2<>fp_base then
  227.     ErrorMsg.impossible "VaxCM.fnegd"
  228.     else V.mnegg(src,dst)
  229. fun fabsd (args as (displace(_,b1), displace(_,b2))) =
  230.     if b1<>fp_base andalso b2<>fp_base
  231.       then ErrorMsg.impossible "VaxCM.fabsd"
  232.       else let
  233.     val lab = V.newlabel()
  234.     in
  235.       V.movg args;  (* movg sets condition codes *)
  236.       V.bgeq (address lab);
  237.       V.mnegg args;
  238.       V.define lab
  239.     end
  240.  
  241. fun cvti2d(src, dst as displace(_,base)) = 
  242.     if base <> fp_base then 
  243.     ErrorMsg.impossible "VaxCM.cvti2d"
  244.     else 
  245.     V.cvtwg(src,dst)
  246.  
  247. fun cbranch NEQ = V.bneq
  248.   | cbranch EQL = V.beql
  249.   | cbranch LEQ = V.bleq
  250.   | cbranch GEQ = V.bgeq
  251.   | cbranch LSS = V.blss
  252.   | cbranch GTR = V.bgtr
  253.  
  254. fun ibranch (cond, op1, op2, label) =
  255.     (V.cmpl(op1, op2); cbranch cond (defer label))
  256.  
  257. (* rangeChk (a, b, lab):  pc <- lab if ((a < 0) or (b <= a)) *)
  258. fun rangeChk (op1, op2, label) = (V.cmpl(op1, op2); V.bgequ (defer label))
  259.  
  260. fun fbranchd (cond, op1, op2, label) =
  261.     (V.cmpg(op1, op2); cbranch cond (defer label))
  262.  
  263. fun defer' j = fn x => j(defer x)
  264. val jmp = defer' V.jmp
  265. val bbs = fn(x,y,l) => V.bbs(x,y, defer l)
  266.  
  267. val comment = V.comment
  268. end
  269.